home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / DEMO / TEXTDEMO.M < prev    next >
Encoding:
Text File  |  1993-05-28  |  9.3 KB  |  268 lines
  1. MODULE TextDemo;
  2.  
  3.  
  4. (*      Megamax Modula-2 Demo zur VDI-Textausgabe
  5.  *      Bei installiertem GDOS werden auch die zuladbaren Fonts verwendet.
  6.  *
  7.  *      Autor: Manuel Chakravarty, erstellt 2. Dezember 1987
  8.  *      Erweiterungen (GDOS-Fonts) von Th. Tempelmann am 25.2.91
  9.  *
  10.  *      Dieses Programm läuft, Dank den Nachfragefunktionen des GEM,
  11.  *      in allen Auflösungen.
  12.  *)
  13.  
  14. FROM SYSTEM IMPORT ASSEMBLER;
  15.  
  16. FROM GrafBase IMPORT black, white, Rectangle, Point, WritingMode,
  17.                      Pnt, Rect, RelZoomRect;
  18.  
  19. FROM GEMGlobals IMPORT TEffectSet, TextEffect, GemChar, FillType,
  20.                        THorJust, TVertJust;
  21.  
  22. FROM GEMEnv IMPORT RC, DeviceHandle, GemHandle, PtrDevParm,
  23.                    DeviceParameter, GemError, GDOSAvailable,
  24.                    InitGem, ExitGem, CurrGemHandle;
  25.  
  26. FROM VDIControls IMPORT LoadFonts, UnloadFonts, SetClipping, DisableClipping;
  27.  
  28. FROM VDIOutputs IMPORT GrafText, FillRectangle;
  29.  
  30. FROM VDIAttributes IMPORT SetTextColor, SetTextEffects, SetFillType,
  31.                           SetFillColor, SetAbsTHeight, SetPtsTHeight,
  32.                           SetTextFace;
  33.  
  34. FROM VDIInquires IMPORT GetTextStyle, GetFaceName, TextExtent, GetFaceInfo;
  35.  
  36. FROM AESGraphics IMPORT GrafMouse, arrow, mouseOn, mouseOff;
  37.  
  38. FROM AESEvents IMPORT KeyboardEvent;
  39.  
  40. FROM AESWindows IMPORT DeskHandle, WSizeMode, WindowElement, WElementSet,
  41.                        WindowSize, CreateWindow, OpenWindow, CloseWindow,
  42.                        DeleteWindow, UpdateWindow;
  43.  
  44. IMPORT GEMBase;
  45.  
  46. FROM Strings IMPORT Append, Copy;
  47. FROM StrConv IMPORT CardToStr;
  48.  
  49. CONST   maxSizes = 64;
  50.  
  51. VAR     dev     : DeviceHandle;         (* VDI-Gerätekennung *)
  52.         hdl     : GemHandle;            (* GEM-Kennung *)
  53.         devpar  : PtrDevParm;
  54.  
  55.         success         : BOOLEAN;
  56.         gemch           : GemChar;
  57.         voidC,top,fonts : CARDINAL;
  58.         voidI           : INTEGER;
  59.         window, fontNr  : CARDINAL;
  60.         size, c         : CARDINAL;
  61.         minCH, maxCH, ch: CHAR;
  62.         windSize, rect  : Rectangle;
  63.         hor             : THorJust;
  64.         vert            : TVertJust;
  65.         mode            : WritingMode;
  66.         height, sizes   : CARDINAL;
  67.         width, line     : CARDINAL;
  68.         charsPerLine    : CARDINAL;
  69.         ypos            : INTEGER;
  70.         fontName        : ARRAY [0..32] OF CHAR;
  71.         fontHandle      : INTEGER;
  72.         aespb           : GEMBase.AESPB;
  73.         vdipb           : GEMBase.VDIPB;
  74.         fontSize        : ARRAY [1..maxSizes] OF INTEGER;
  75.         allchars, str   : ARRAY [0..256] OF CHAR;
  76.         ok              : BOOLEAN;
  77.         
  78.  
  79. PROCEDURE getFontSizes (VAR n: CARDINAL);
  80.   (*
  81.    * Ermittelt die einstellbaren Font-Größen und liefert die Anzahl.
  82.    * In "fontSize" sind die möglichen Größen enthalten, die größte steht
  83.    * im ersten Feld, die kleinste im letzten.
  84.    *)
  85.   VAR prev, size: INTEGER; prevH, cellH: CARDINAL;
  86.   BEGIN
  87.     size:= 24;
  88.     prevH:= 0;
  89.     n:= 0;
  90.     LOOP
  91.       prev:= size;
  92.       SetPtsTHeight (dev, size-1, voidC,voidC,voidC,cellH); (* Größe setzen *)
  93.       IF GemError () THEN END;          (* GemError-Flag ggf. rücksetzen *)
  94.       size:= vdipb.iooff^[0];           (* nächstpassende Größe ermitteln *)
  95.       IF size = prev THEN EXIT END;     (* alle Größen ermittelt *)
  96.       IF cellH # prevH THEN INC (n) END;
  97.       fontSize[n]:= size;
  98.       IF n = maxSizes THEN EXIT END;
  99.       prevH:= cellH
  100.     END;
  101.   END getFontSizes;
  102.  
  103. PROCEDURE setFontSize (size: CARDINAL; VAR cellW, cellH: CARDINAL);
  104.   (*
  105.    * Setzt eine Font-Größe.
  106.    *)
  107.   BEGIN
  108.     SetPtsTHeight (dev, size, voidC, voidC, cellW, cellH); (* Größe setzen *)
  109.     IF GemError () THEN END;              (* GemError-Flag ggf. rücksetzen *)
  110.   END setFontSize;
  111.  
  112. PROCEDURE getFontRange (VAR min, max: CHAR);
  113.   VAR c: CARDINAL; i: INTEGER; mi, ma: CARDINAL;
  114.   BEGIN
  115.     GetFaceInfo (dev, mi, ma, c, c, c, c, c, i, i, i, i);
  116.     min:= CHR (mi); max:= CHR (ma);
  117.   END getFontRange;
  118.  
  119. PROCEDURE termination;
  120.   (*
  121.    * Fonts freigeben und GEM abmelden
  122.    *)
  123.   BEGIN
  124.   END termination;
  125.  
  126. BEGIN
  127.  
  128.         (* Anmeldung beim GEM, liefert Gerätekennung 'dev' *)
  129.  
  130.   InitGem (RC, dev, success);
  131.   IF success THEN             (* Falls Anmeldung erfolgreich, ... *)
  132.   
  133.     hdl:=CurrGemHandle ();      (* GEM-Kennung für Abmeldung ermitteln *)
  134.     
  135.     GrafMouse (arrow, NIL);     (* Mauszeiger zum Pfeil machen *)
  136.  
  137.     GEMBase.GetPBs (hdl, vdipb, aespb); (* für "GetFaceName" *)
  138.     
  139.         (* Weitere eventuelle Fonts laden, wenn GDOS installiert ist *)
  140.  
  141.     IF GDOSAvailable () THEN
  142.       LoadFonts (dev, 0, fonts)
  143.     ELSE
  144.       fonts:= 0;
  145.     END;
  146.     devpar:= DeviceParameter (dev);
  147.     INC (fonts, devpar^.fonts); (* Anzahl der Fonts: Systemfonts mitzählen *)
  148.   
  149.         (*  Melde ein Fenster beim AES an.
  150.          *  Die Fensterkennung wird vom AES in 'window' geliefert.
  151.          *  Und öffne das Fenster anschließend (Fenster wird sichtbar).
  152.          *)
  153.     CreateWindow (WElementSet {}, WindowSize (DeskHandle, workSize), window);
  154.     OpenWindow (window, RelZoomRect (WindowSize (DeskHandle, workSize),
  155.                                      900, 900) );
  156.  
  157.         (* Nun im Fenster den Text mit jedem vorhandenen Font anzeigen *)
  158.  
  159.     FOR fontNr:= 1 TO fonts DO
  160.  
  161.         (* Vorbereitungen zum Beschreiben des Windows *)
  162.  
  163.       UpdateWindow (TRUE);        (* Melde Start der Ausgabe in das Fenster *)
  164.       GrafMouse (mouseOff, NIL);  (* Mauszeiger unsichtbar machen *)
  165.       
  166.       windSize:=WindowSize (window, workSize); (* Arbeitsbereich ermitteln *)
  167.       SetClipping (dev, windSize);             (* Ausgabebegrenzung *)
  168.  
  169.         (* Font wählen *)
  170.  
  171.       GetFaceName (dev, fontNr, fontName);     (* Namen des Fonts ermitteln *)
  172.       fontHandle:= vdipb.iooff^[0];            (* ID des Fonts ermitteln *)
  173.       SetTextFace (dev, fontHandle);           (* Font für Ausgabe wählen *)
  174.       getFontSizes (sizes);                    (* Größen des Fonts ermitteln *)
  175.       
  176.       IF sizes > 0 THEN
  177.       
  178.           (* Fontgröße einstellen: zuerst einmal die kleinste Größe *)
  179.   
  180.         setFontSize (fontSize[sizes], width, height);
  181.         ypos:= 2*height;                         (* Startzeile für Textausgabe *)
  182.   
  183.           (* Das Fenster wird weiß gefüllt *)
  184.   
  185.         SetFillColor (dev, white);
  186.         SetFillType (dev, solidFill);
  187.         FillRectangle (dev, windSize);
  188.   
  189.           (* Text im Fenster normal und ausgeben *)
  190.   
  191.         SetTextColor (dev, black);            (* Textfarbe  : schwarz *)
  192.         SetTextEffects (dev, TEffectSet{});   (* Texteffekte: keine *)
  193.         GrafText (dev, Pnt(windSize.x,windSize.y + ypos), fontName);
  194.       
  195.           (* Text fett und unterstrichen ausgeben *)
  196.       
  197.         SetTextEffects (dev, TEffectSet {thickText, underlineText});
  198.         INC (ypos, height+2);
  199.         GrafText (dev, Pnt(windSize.x,windSize.y + ypos), fontName);
  200.       
  201.           (* Text umrahmt ausgeben.  *)
  202.         
  203.         SetTextEffects (dev, TEffectSet {outlineText});
  204.         INC (ypos, height+2);
  205.         GrafText (dev, Pnt(windSize.x,windSize.y + ypos), fontName);
  206.         
  207.           (* Verfügbare Font-Größen anzeigen *)
  208.         
  209.         SetTextEffects (dev, TEffectSet {});
  210.         str:= "Verfügbare Font-Größen:";
  211.         FOR size:= sizes TO 1 BY -1 DO
  212.           Append (" ", str, ok);
  213.           Append (CardToStr (fontSize[size], 0), str, ok);
  214.         END;
  215.         INC (ypos, height+6);
  216.         GrafText (dev, Pnt(windSize.x,windSize.y + ypos), str);
  217.         
  218.           (* Und nun den kompletten Font in allen Größen zeigen *)
  219.       
  220.         (* zuerst einen String mit allen vorhandenen Zeichen erzeugen *)
  221.         getFontRange (minCH, maxCH); (* ermittelt erstes und letztes Zeichen *)
  222.         IF minCH = 0C THEN minCH:= 1C END; (* 0C darf nicht in String vorkommen *)
  223.         allchars:= '';
  224.         c:= 0;
  225.         FOR ch:= minCH TO maxCH DO
  226.           allchars[c]:= ch;
  227.           INC (c);
  228.         END;
  229.         allchars[c]:= ''; (* String-Terminierung *)
  230.         SetTextEffects (dev, TEffectSet {});
  231.         FOR size:= sizes TO 1 BY -1 DO
  232.           INC (ypos, 4);
  233.           setFontSize (fontSize[size], width, height);
  234.           (* Anzahl Zeichen, die in eine Zeile passen, berechnen: *)
  235.           charsPerLine:= ORD (windSize.w) DIV width;
  236.           line:= 0;
  237.           LOOP (* alle Zeichen ggf. in mehreren Zeilen darstellen *)
  238.             Copy (allchars, line*charsPerLine, charsPerLine, str, ok);
  239.             IF LENGTH (str) = 0 THEN EXIT END;
  240.             INC (ypos, height+2);
  241.             GrafText (dev, Pnt(windSize.x,windSize.y + ypos), str);
  242.             INC (line);
  243.           END;
  244.         END;
  245.       
  246.       END;
  247.       
  248.       DisableClipping (dev);    (* Ausgabebegrenzung ausschalten *)
  249.       
  250.       UpdateWindow (FALSE);     (* Ausgabe in das Fenster beendet *)
  251.       GrafMouse (mouseOn, NIL); (* Mauszeiger wieder sichtbar machen *)
  252.       
  253.       KeyboardEvent (gemch);       (* Warte auf einen Tastendruck *)
  254.     
  255.     END;
  256.  
  257.     CloseWindow (window);     (* Fenster schließen (Unsichtbar machen) *)
  258.     DeleteWindow (window);    (* und anschließend löschen *)
  259.     
  260.     IF GDOSAvailable () THEN
  261.       UnloadFonts (dev, 0)
  262.     END;
  263.     
  264.     ExitGem (hdl);          (* Beim GEM abmelden; hier wird 'hdl' gebraucht *)
  265.     
  266.   END;
  267. END TextDemo.
  268.